home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / OBJBFILE.INC < prev    next >
Text File  |  1994-02-22  |  11KB  |  419 lines
  1.  
  2. {SECTION  BFILE_object }
  3. procedure BFILE_object.init(fn : string; recsz,FMode : integer);
  4. var create : boolean;
  5.      begin
  6.      opened   := false;
  7.      filename := fn;
  8.      recsiz   := 1;
  9.      hdrsiz   := 0;
  10.      hdrptr   := NIL;
  11.      err      := 0;
  12.      curr     := -1;  { valid is 0 .. count-1 }
  13.      if (recsz > 0) and (recsz < 4097) then recsiz := recsz;
  14.      create := false;
  15.      if FMode < 0 then create := true
  16.      else              FileMode := FMode;
  17.      BFILE_object.open(filename,create);
  18.      end;
  19.  
  20.  
  21. procedure BFILE_object.InitWithHdr(fn : string; recsz,hdsz,FMode : integer);
  22. var create : boolean;
  23.      begin
  24.      opened   := false;
  25.      filename := fn;
  26.      recsiz   := 1;
  27.      hdrptr   := NIL;
  28.      hdrsiz   := 0;
  29.      err      := 0;
  30.      curr     := 0;  { valid is 1 to count }
  31.      create := false;
  32.      if FMode < 0 then create := true
  33.      else              FileMode := FMode;
  34.      if (recsz > 0) and (recsz < 4097)     then recsiz := recsz;
  35.      if (hdsz > 0)  and (hdsz < BFILE_maxheader) then
  36.           begin
  37.           if (MemAvail > BFILE_maxheader) then
  38.                begin
  39.                hdrsiz := hdsz;
  40.                NEW(hdrptr);
  41.                fillchar(hdrptr^,sizeof(BFILE_headerbuf_type),0);
  42.                end;
  43.           end;
  44.      BFILE_object.open(filename,create);
  45.      end;
  46.  
  47.  
  48. Procedure BFILE_object.SetHdrSiz  (hdsz : integer);
  49.      begin  { After discovering header size of existing file }
  50.      if hdrptr = NIL then exit;
  51.      if (hdsz > 0) and (hdsz < BFILE_maxheader) then
  52.           begin
  53.           hdrsiz := hdsz;
  54.           ReadHeader;
  55.           curr := 0;   {BOF for fetchnext}
  56.           end
  57.      else begin
  58.           hdrsiz := 0;
  59.           curr := -1;  {BOF for fetchnext}
  60.           end;
  61.      end;
  62.  
  63.  
  64. Function BFILE_object.IOResultErrChk : boolean;
  65. var xerr : integer;
  66.      begin
  67.      xerr := IORESULT;
  68.      if err = 0 then err := xerr; { Leave Err alone if non-Zero }
  69.      if xerr <> 0 then
  70.           begin
  71.           writeln(DOSErrStr(xerr),'[',filename,']');
  72.           IOResultErrChk := true;
  73.           end
  74.      else IOResultErrChk := false;
  75.      end;
  76.  
  77.  
  78. Function BFILE_object.NoError : boolean;
  79.      begin
  80.      NoError := (err = 0);
  81.      end;
  82.  
  83.  
  84. Function  BFILE_object.Count : longint;
  85. var rs,hs : longint;
  86.      begin
  87.      rs := recsiz; hs := hdrsiz;
  88.      count := ((filesize(fil)+1) - hs) div rs;
  89.      end;
  90.  
  91.  
  92. Function  BFILE_object.RecAddress(n : longint) : longint;
  93. var rs,hs : longint;
  94.      begin
  95.      rs := recsiz; hs := hdrsiz;
  96.      if hs = 0 then
  97.           RecAddress := n * rs
  98.      else RecAddress := (n-1)*rs + hs;
  99.      end;
  100.  
  101.  
  102. Procedure BFILE_object.open(fn : string; create : boolean);
  103.      begin
  104.      if opened then BFILE_object.close;
  105.      assign(fil,fn);
  106.      if create then
  107.           begin {create empty file}
  108.          {$I-} ReWrite(fil,1); {$I+}
  109.           if not IOResultErrChk and (hdrsiz > 0) then
  110.                begin {write empty header}
  111.                UpdateHeader;
  112.                end;
  113.           end
  114.      else begin
  115.           {$I-} Reset(fil,1); {$I+}
  116.           IOResultErrChk;
  117.           if hdrsiz > 0 then ReadHeader;
  118.           end;
  119.      if NoError then opened := true;
  120.      end;
  121.  
  122.  
  123. procedure BFILE_object.close;
  124. var l : longint;
  125.     i : integer;
  126.     ok : boolean;
  127.      begin
  128.      if opened then
  129.           begin
  130.          {$I-} SYSTEM.Close(fil); {$I+}
  131.           IOResultErrChk;
  132.           opened := false;
  133.           end;
  134.      end;
  135.  
  136.  
  137. procedure BFILE_object.done;
  138.      begin
  139.      if not opened then exit;
  140.      BFILE_object.close;
  141.      end;
  142.  
  143.  
  144. procedure BFILE_object.dump;
  145. var l : longint;
  146.     results : integer;
  147.     zbuf : array[1..16] of byte;
  148.      begin
  149.      l := 0;
  150.      if not opened then exit;
  151.      write('Dump of File: ',filename,'   Size:',filesize(fil),
  152.                                        '  Count:',count);
  153.      if hdrsiz > 0 then
  154.           writeln('   Header size:',hdrsiz)
  155.      else writeln('   No header');
  156.      while l < filesize(fil) do
  157.           begin
  158.          {$I-} SYSTEM.seek(fil,l); {$I+}
  159.           IOResultErrChk;
  160.           if NoError then
  161.                begin
  162.                fillchar(zbuf,sizeof(zbuf),0);
  163.               {$I-} SYSTEM.blockread(fil,zbuf,16,results); {$I+}
  164.                IOResultErrChk;
  165.                if NoError then
  166.                    begin
  167.                    writeln(Buf16ToHexStr(l,16,zbuf,true));
  168.                    end;
  169.                end;
  170.           l := l + 16;
  171.           end;
  172.      end;
  173.  
  174.  
  175. procedure BFILE_object.SmartDump;
  176. var l : longint;
  177.     results : integer;
  178.     rbuf : array[1..4096] of byte;
  179.     zbuf : array[1..16] of byte;
  180.     i,j,first  : integer;
  181.      begin
  182.      l := 0; first := 0;
  183.      if not opened then exit;
  184.      writeln('SmartDump of File: ',filename,'  Size:',filesize(fil),
  185.              '  HdrSiz:',hdrsiz,'  RecSiz:',recsiz,'  Recs:',count);
  186.      ReadHeader;
  187.      if NoError then
  188.           begin
  189.           first := 1;
  190.           i := 1;
  191.           writeln('Header - size=',hdrsiz);
  192.           while i < hdrsiz do
  193.               begin
  194.               move(hdrptr^[i],zbuf,16);
  195.               writeln(Buf16ToHexStr(i,(hdrsiz-i),zbuf,true));
  196.               i := i + 16;
  197.               end;
  198.           if hdrsiz > 16 then writeln(' ');
  199.           end;
  200.      for j := first to count do
  201.           begin
  202.           fillchar(rbuf,sizeof(rbuf),0);
  203.           fetchN(j,rbuf);
  204.           if NoError then
  205.                begin
  206.                i := 1;
  207.                writeln('Record - ',j,'    size=',recsiz);
  208.                while i < recsiz do
  209.                    begin
  210.                    move(rbuf[i],zbuf,16);
  211.                    writeln(Buf16ToHexStr(i,(recsiz-i),zbuf,true));
  212.                    i := i + 16;
  213.                    end;
  214.                end;
  215.           if recsiz > 16 then writeln(' ');
  216.           end;
  217.      end;
  218.  
  219.  
  220. procedure BFILE_object.clearfile;
  221. var fn : string;
  222.      begin
  223.      err := 0;
  224.      fn := filename;
  225.      BFILE_object.close;
  226.      BFILE_object.open(fn,true);      { do a REWRITE }
  227.      end;
  228.  
  229.  
  230. procedure BFILE_object.refreshfile;
  231. var fn : string;
  232.      begin
  233.      err := 0;
  234.      fn := filename;
  235.      BFILE_object.close;
  236.      BFILE_object.open(fn,false);      { do a RESET }
  237.      end;
  238.  
  239.  
  240.  
  241. Function  BFILE_object.seekN(n : longint) : boolean;
  242.      begin
  243.      seekN := false;
  244.      if not opened then exit;
  245.      if (hdrsiz > 0) and (n > count) then exit;
  246.      if (hdrsiz = 0) and (n > (count-1)) then exit;
  247.      curr     := n;
  248.      position := RecAddress(curr);
  249.    { writeln('seeking ',curr,'  ',position, '    filesize ',filesize(fil));}
  250.     {$I-} SYSTEM.seek(fil,position); {$I+}
  251.      IOResultErrChk;
  252.      SeekN    := NoError;
  253.      end;
  254.  
  255.  
  256. Function BFILE_object.ReadHeader : boolean;
  257. var results : integer;
  258.      begin
  259.      ReadHeader := false;
  260.      if hdrptr = NIL then exit;
  261.      if hdrsiz = 0 then exit;
  262.      if not opened then exit;
  263.     {$I-} SYSTEM.seek(fil,0); {$I+}
  264.      IOResultErrChk;
  265.      if NoError then
  266.           begin
  267.          {$I-} SYSTEM.blockread(fil,hdrptr^,hdrsiz,results); {$I+}
  268.           IOResultErrChk;
  269.           end;
  270.      ReadHeader := NoError;
  271.      end;
  272.  
  273.  
  274. Function BFILE_object.UpDateHeader : boolean;
  275. var results : integer;
  276.      begin
  277.      UpDateHeader := false;
  278.      if hdrptr = NIL then exit;
  279.      if hdrsiz = 0 then exit;
  280.      if not opened then exit;
  281.     {$I-} SYSTEM.seek(fil,0); {$I+}
  282.      IOResultErrChk;
  283.      if NoError then
  284.           begin
  285.          {$I-} SYSTEM.blockwrite(fil,hdrptr^,hdrsiz,results); {$I+}
  286.           IOResultErrChk;
  287.           end;
  288.      UpDateHeader := NoError;
  289.      end;
  290.  
  291.  
  292.  
  293. Function  BFILE_object.storeN(n : longint; var rec) : boolean;
  294. var results : integer;
  295.     ok      : boolean;
  296.      begin
  297.      StoreN := false;
  298.      if not opened then exit;
  299.      err := 0;
  300.      ok  := false;
  301.      if n >= count then
  302.           begin
  303.           position := RecAddress(n);
  304.          {$I-} SYSTEM.seek(fil,position); {$I+}
  305.           ok := not IOResultErrChk;
  306.           end
  307.      else if ((hdrsiz > 0) and (n < 1)) or (n < 0) then
  308.           begin
  309.           ok := false;
  310.           position := 0;
  311.           curr := 0;
  312.           end
  313.      else ok := seekN(n);
  314.      if ok then
  315.           begin
  316.          {$I-} SYSTEM.blockwrite(fil,rec,recsiz,results); {$I+}
  317.           storeN := IOResultErrChk;
  318.           end;
  319.      storeN := NoError;
  320.      end;
  321.  
  322.  
  323. Function  BFILE_object.append(var rec) : boolean;
  324. var results : integer;
  325.      begin
  326.      append := false;
  327.      if not opened then exit;
  328.      err := 0;
  329.      append := storen(count,rec);
  330.      end;
  331.  
  332.  
  333. function BFILE_object.fetchN(n : longint; var rec) : boolean;
  334. var results : integer;
  335. var ok : boolean;
  336.      begin
  337.      fillchar(rec,recsiz,0);
  338.      fetchN := false;
  339.      if not opened then exit;
  340.      err := 0;
  341.      if seekN(n) then
  342.           begin
  343.          {$I-} SYSTEM.blockread(fil,rec,recsiz,results); {$I+}
  344.           IOResultErrChk;
  345.           end
  346.      else err := BFILE_Bad_Recnum_ERR;
  347.      fetchN := NoError;
  348.      end;
  349.  
  350.  
  351. Function BFILE_object.fetchnext(var rec) : boolean;
  352. var n  : integer;
  353.      begin
  354.      fetchnext := false;
  355.      if not opened then exit;
  356.      err := 0;
  357.      n := curr;
  358.      inc(n);
  359.      fetchnext := fetchn(n,rec);
  360.      end;
  361.  
  362.  
  363.  
  364. Procedure BFILE_object.export (fn : string; workproc : BFILE_RecToStringproc;
  365.                               var rec; purgedata : boolean);
  366. var TEXTF : TEXT;
  367.     s   : string;
  368.     ok  : boolean;
  369.     i : integer;
  370.      begin
  371.      if not opened then exit;
  372.      err := 0;
  373.      SYSTEM.assign(TEXTF, fn);
  374.      {$I-} SYSTEM.rewrite(TEXTF);  {$I+}
  375.      if IOResultErrChk then exit;
  376.      curr := 0;
  377.      while ok do
  378.          begin
  379.          ok := BFILE_object.fetchnext(rec);
  380.          if ok then
  381.               begin
  382.               workproc(rec,s);
  383.               writeln('exported  ',curr:3,' [',s,']');
  384.               {$I-} SYSTEM.writeln(TEXTF,s); {$I+}
  385.               end;
  386.          end;
  387.      {$I-} SYSTEM.Close(TEXTF); {$I+}
  388.      ok := not IOResultErrChk;
  389.      end;
  390.  
  391.  
  392. Procedure BFILE_object.import (fn : string; workproc : BFILE_StringToRecproc;
  393.                               var rec; purgedata : boolean);
  394. var TEXTF : TEXT;
  395.     s   : string;
  396.     ok  : boolean;
  397.     i : integer;
  398.      begin
  399.      if not opened then exit;
  400.      err := 0;
  401.      SYSTEM.assign(TEXTF, fn);
  402.      {$I-} SYSTEM.reset(TEXTF);  {$I+}
  403.      ok := not IOResultErrChk;
  404.      if not ok then exit;
  405.      while not EOF(TEXTF) do
  406.           begin
  407.           readln(TEXTF,s);
  408.           if s <> '' then
  409.                begin
  410.                workproc(s,rec);
  411.                BFILE_object.storen(-1,rec);
  412.                end;
  413.           end;
  414.      {$I-} SYSTEM.Close(TEXTF); {$I+}
  415.      ok := not IOResultErrChk;
  416.      BFILE_object.refreshfile;
  417.      end;
  418.  
  419.